unit upachil;

(* cpcPaChi - Un compilador de Pascal chiquitito para CPC
   Por Nacho Cabanes
   
   uPachiL - unidad "Lexer" (analizador lexico - scanner)
   
   Versiones hasta la fecha:
   
   Num.   Fecha       Cambios
   ---------------------------------------------------
   0.17  20-Ago-2008  En caso de fichero inexistente,
                      sale avisando, en vez de Runtime Error
                      
   0.15  15-Ago-2008  Un nuevo ObtenerToken reemplaza a
                      ObtenerIdentificador y similares.

   0.12  07-Ago-2008  Corregido un error en obtenerIdentificador
                      cuando habia varias lineas en blanco ->
                      repeat..until

   0.09  22-Jun-2008  Los mensajes de error muestran Fila y Col

   0.08  20-Abr-2008  Los identificadores pueden contener
                      cifras numericas.
                      Permite comentarios con llaves
                      y con parentesis-asterisco.

   0.07  06-Abr-2008  Anadido "leerCualquierSimbolo"
   
   0.05  31-Mar-2008  Muestra info (opcional) de depuracion
                      Salta espacios en blanco (preliminar)

   0.03  25-Mar-2008  Primera version del analizador lexico:
                      es capaz de devolver un identificador,
                      un entero y de comprobar si el siguiente
                      simbolo es uno prefijado;
                      lee linea a linea del fichero de entrada
*)


interface

uses crt, upachid; (* Para la estructura Token *)

  procedure errorFatal(mensaje: string);
  function abrirFicheroEntrada(nombre: string): boolean;
  function obtenerLetra: char;
  function obtenerToken: token;
  function obtenerCadena: string;
  {function obtenerIdentificador: string;
  function obtenerEntero: string;
  function obtenerEnteroOIdentificador: string;}
  procedure devolverToken(t: token);
  procedure cerrarFicheroEntrada;
  procedure leerSimbolo(simbolo: string);
  {function leerCualquierSimbolo: char;}

  var
    lineaDeEntrada: string;
    finFicheroEntrada: boolean;

implementation

var
  ficheroEntrada: text;
  lineaActual: integer;
  posicionLineaActual: integer;
  tokenGuardado: token;
  
  espacioBlanco: set of char =  [chr(32), chr(10), chr(13), chr(9)];
  depurando: boolean = false;

  
(* Muestra un mensaje de error y abandona el programa *)
procedure errorFatal(mensaje: string);
begin
   write('Linea: ',lineaActual,'. Pos: ',posicionLineaActual+1,'. ');
   writeln(mensaje);
   halt;
end;

  
  
(* Abre el fichero de entrada. Devuelve FALSE si no se
ha podido *)
function abrirFicheroEntrada(nombre: string): boolean;
begin
   lineaActual := 0;
   posicionLineaActual := 0;
   lineaDeEntrada := '';
   tokenGuardado.valor := '';
   
   assign( ficheroEntrada, nombre );
   {$I-}
   reset( ficheroEntrada );
   {$I+}   

   if ioResult = 0 then
     begin
     finFicheroEntrada := false;
     abrirFicheroEntrada := true;
     end
   else
     begin
     errorFatal('Fichero no encontrado!');
     {finFicheroEntrada := true;
     abrirFicheroEntrada := false;}
     end;
end;


(* Cerrar fichero de entrada (al final del analisis) *)
procedure cerrarFicheroEntrada;
begin
  close(ficheroEntrada);
end;

(* Lee una linea del fichero de entrada. Solo para uso interno del lexer *)
procedure leerLinea;
begin
  readln( ficheroEntrada, lineaDeEntrada );
  if eof(ficheroEntrada) then
    begin
    writeln('Fin de fichero');
    finFicheroEntrada := true;
    end;
  if (depurando) then
    writeln('Leida linea: ', lineaDeEntrada);
end;


(* Obtiene una letra del fichero. Se apoya en leerLinea: toma la
siguiente letra de "LineaDeEntrada", o lee otra linea del fichero
si la actual ha terminado *)
function obtenerLetra: char;
begin
  (* Si hay varias lineas en blanco, las salto *)
  while (lineaDeEntrada = '')
    or (posicionLineaActual >= length(lineaDeEntrada)) do
  begin
    leerLinea;
    inc(lineaActual);
    posicionLineaActual := 0;
  end;
  (* Si quedan caracteres en la actual, leo el siguiente *)
  if posicionLineaActual < length(lineaDeEntrada) then
    begin
    inc(posicionLineaActual);
    obtenerLetra := lineaDeEntrada[posicionLineaActual];
    end;
end;


(* Retroceder, si hemos leido una letra de mas *)
procedure devolverLetra;
begin
 if posicionLineaActual > 0 then
   dec(posicionLineaActual);
end;

(* Retroceder, si hemos leido una letra de mas *)
procedure devolverToken(t: token);
begin
  tokenGuardado := t;
end;


(* Saltar espacios en blanco, para permitir formato libre *)
procedure saltarBlancos;
var
  siguiente, otra: char;
  saltadoAlgo: boolean;
begin
  repeat
  saltadoAlgo := false;  
  siguiente := obtenerLetra;  
  
    (* Salto blancos "convencionales" *)
    while siguiente in espacioBlanco do
      begin
      siguiente := obtenerLetra;
      saltadoAlgo := true;
      end;
    devolverLetra;

    (* Salto comentarios entre parentesis-asterisco *)
    if (siguiente = '(') then 
      begin
      otra := obtenerLetra; (* Recupero el parentesis *)
      otra := obtenerLetra; (* Y ahora miro si hay ASTERISCO *)
      {devolverLetra;}
      if otra = '*' then        
        begin
        repeat
          siguiente := obtenerLetra;
          saltadoAlgo := true;
        until (siguiente = '*') and (lineaDeEntrada[posicionLineaActual+1] = ')');
        obtenerLetra; (* Salto el PARD final *)
        end
      else
        begin 
        devolverLetra;
        devolverLetra;
        {devolverLetra;
        devolverLetra;}
        end;
      end;
    
    (* Salto comentarios entre llaves *)
    if (siguiente = '{') then
      repeat
        siguiente := obtenerLetra;
        saltadoAlgo := true;
      until siguiente = '}';  

  until not saltadoAlgo;
end;


function obtenerToken: token;
var
  lexema: string;
  letra, nuevaLetra: char;
  tokenLeido: token;
begin  
  if tokenGuardado.valor <> '' then
    begin
    obtenerToken := tokenGuardado;
    tokenGuardado.valor := '';
    exit;
    end;
  saltarBlancos;
  letra := upcase(obtenerLetra);
  tokenLeido.valor := letra;
  tokenLeido.posX := posicionLineaActual;
  tokenLeido.posY := LineaActual;
  case letra of 
    (* Simbolos sin posible confusion *)
    '.': tokenLeido.tipo := tkPUNTO;
    ',': tokenLeido.tipo := tkCOMA;
    ';': tokenLeido.tipo := tkPYC;
    '=': tokenLeido.tipo := tkIGUAL;
    '''': tokenLeido.tipo := tkCOMILLA;
    (* Dos puntos: quiza asignacion *)
    ':': 
      begin
      tokenLeido.tipo := tkDOSP;
      nuevaLetra := upcase(obtenerLetra);
      if nuevaLetra = '=' then
        begin
          tokenLeido.valor := tokenLeido.valor + nuevaLetra;
          tokenLeido.tipo := tkASIGN;
        end
      else
        devolverLetra;
      end;
    (* Parentesis: quiza comienzo de comentario *)
    '(': 
      begin
      tokenLeido.tipo := tkPARI;
      (*nuevaLetra := upcase(obtenerLetra);
        if nuevaLetra in ['A'..'Z'] then
          tokenLeido.valor := tokenLeido.valor + letra;*)
      end;
    ')': tokenLeido.tipo := tkPARD;
    (* Identificadores *)
    'A'..'Z': 
      begin
      tokenLeido.tipo := tkID;
      repeat
        nuevaLetra := upcase(obtenerLetra);
        if nuevaLetra in ['A'..'Z','0'..'9'] then
          tokenLeido.valor := tokenLeido.valor + nuevaLetra;
      until not (nuevaLetra in ['A'..'Z','0'..'9']);
      devolverLetra;
      end;
    (* Mayor o mayor_igual *)
    '>': 
      begin
      tokenLeido.tipo := tkMAYOR;
      nuevaLetra := upcase(obtenerLetra);
      if nuevaLetra = '=' then
        begin
          tokenLeido.valor := tokenLeido.valor + nuevaLetra;
          tokenLeido.tipo := tkMAYORI;
        end
      else
        devolverLetra;
      end;
    (* Menor o menor_igual o distinto *)
    '<': 
      begin
      tokenLeido.tipo := tkMENOR;
      nuevaLetra := upcase(obtenerLetra);
      if nuevaLetra = '=' then
        begin
          tokenLeido.valor := tokenLeido.valor + nuevaLetra;
          tokenLeido.tipo := tkMENORI;
        end
      else if nuevaLetra = '>' then
        begin
          tokenLeido.valor := tokenLeido.valor + nuevaLetra;
          tokenLeido.tipo := tkDISTINTO;
        end
      else
        devolverLetra;
      end;
    (* Numero entero *)
    '0'..'9': 
      begin
      tokenLeido.tipo := tkENTERO;
      repeat
        nuevaLetra := upcase(obtenerLetra);
        if nuevaLetra in ['0'..'9'] then
          tokenLeido.valor := tokenLeido.valor + nuevaLetra;
      until not (nuevaLetra in ['0'..'9']);
      devolverLetra;
      end
    (* Simbolos no reconocidos *)      
    else
      errorFatal('Error sintactico');
  end;
  if (depurando) then
    writeln('Token: ', tokenLeido.tipo, '=' , tokenLeido.valor, ' Pos '
      , tokenLeido.posX, ',', tokenLeido.posY, '.');  
  obtenerToken := tokenLeido;
end;

function obtenerCadena: string;
var
  cadena: string;
  letra, nuevaLetra: char;
  tokenLeido: token;
begin  
  letra := obtenerLetra;
  cadena := letra;
  repeat
    letra := obtenerLetra;
    if letra <> '''' then
      cadena := cadena + letra;
  until letra = '''';
  devolverLetra;  
  obtenerCadena := cadena;  
end;


(* Espera un cierto simbolo *)
procedure leerSimbolo(simbolo:string);
var
  simboloLeido: token;
begin
  saltarBlancos;
  simboloLeido := obtenerToken;
  (*if (depurando) then
    writeln('Simbolo: ', simboloLeido.valor);*)
  if simbolo <> simboloLeido.valor then
    errorFatal('Se esperaba '+simbolo+' y se ha encontrado '
    +simboloLeido.valor);
end;

(* Leer cualquier simbolo: lee el siguiente no-blanco y lo devuelve *)
{function leerCualquierSimbolo: string;
var
  letra: char;
begin
  saltarBlancos;
  letra := obtenerLetra;
  if (depurando) then
    writeln('Simbolo: ', letra);
  leerCualquierSimbolo := letra;
end;}



begin
end.
